From: Camm Maguire Date: Thu, 8 Oct 2026 12:46:53 +0000 (+0000) Subject: [PATCH] X-Git-Tag: archive/raspbian/2.7.1-36+rpi1^2~2 X-Git-Url: https://dgit.raspbian.org/%22http://www.example.com/cgi/%22/%22http:/www.example.com/cgi/%22?a=commitdiff_plain;h=98f87ef2d0b5f7373bb0fca401d1029394977603;p=gcl27.git [PATCH] TODO: Put a short summary on the line above and replace this paragraph with a longer explanation of this change. Complete the meta-information with other relevant fields (see below for details). To make it easier, the information below has been extracted from the changelog. Adjust it or drop it. Gbp-Pq: Name Version_2_7_2pre38 --- diff --git a/Makefile.am b/Makefile.am index 44720f39..dfa1ce07 100644 --- a/Makefile.am +++ b/Makefile.am @@ -467,7 +467,7 @@ ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl cp $(patsubst %.o,%.*,$<) $(@D) -%.go: %.o mod_gcl/recompile #FIXME parallel +%.go: %.o unixport/saved_ansi_gcl #FIXME parallel $(CC) $(AM_CPPFLAGS) -I $(>$@ diff --git a/Makefile.in b/Makefile.in index 0c0f13e4..80912299 100644 --- a/Makefile.in +++ b/Makefile.in @@ -4798,7 +4798,7 @@ ansi_gcl0/%.o: clcs/%.lisp | unixport/ansi_gcl0 ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl cp $(patsubst %.o,%.*,$<) $(@D) -%.go: %.o mod_gcl/recompile #FIXME parallel +%.go: %.o unixport/saved_ansi_gcl #FIXME parallel $(CC) $(AM_CPPFLAGS) -I $(>$@ diff --git a/cmpnew/gcl_cmpif.lsp b/cmpnew/gcl_cmpif.lsp index cf76819c..623a273d 100644 --- a/cmpnew/gcl_cmpif.lsp +++ b/cmpnew/gcl_cmpif.lsp @@ -79,11 +79,32 @@ (defun real-bnds (t1) (num-type-bounds t1)) -(defun two-tp-inf (fn t2 &aux (t2 (real-bnds (type-and #treal t2)))) +(defun =-bnds (tp &aux (ctpn (si::tp-type (tp-and tp #t(complex* real (not (real 0 0))))))) + (list (real-bnds (real-imag-tp ctpn t)) (real-bnds (real-imag-tp ctpn nil)) + (real-bnds (tp-or (tp-and tp #treal) + (real-imag-tp (si::tp-type (tp-and tp #t(complex* real (real 0 0)))) t))))) + +(defun =-tp (tp &aux (l (=-bnds tp))) + (flet ((f (x) (when x (cons 'real x)))) + (tp-or (cmp-norm-tp `(complex* ,(f (car l)) ,(f (cadr l)))) + (tp-or (cmp-norm-tp (f (caddr l))) + (cmp-norm-tp `(complex* ,(f (caddr l)) (real 0 0))))))) + +(defun atomic=-tp (tp &aux (l (=-bnds tp))) + (flet ((f (x) (when (and (numberp (car x)) (numberp (cadr x)) (= (car x) (cadr x))) (car x)))) + (cond ((caddr l) + (unless (or (car l) (cadr l)) + (let ((r (f (caddr l)))) + (when r + (cmp-norm-tp `(or (real ,r ,r) (complex* (real ,r ,r) (real 0 0)))))))) + ((let ((cr (f (car l)))(ci (f (cadr l)))) + (when (and cr ci) + (cmp-norm-tp `(complex* (real ,cr ,cr) (real ,ci ,ci))))))))) + +(defun two-tp-inf (fn t2o &aux (t2o (type-and t2o #tnumber))(t2 (real-bnds (tp-and #treal t2o)))) (case fn - (= (cmp-norm-tp `(real ,(or (car t2) '*) ,(or (cadr t2) '*)))) - (/= (if (when (numberp (car t2)) (eql (car t2) (cadr t2))) - (cmp-norm-tp `(and number (not (real ,@t2)))) #treal)) + (= (=-tp t2o)) + (/= (tp-and #tnumber (tp-not (atomic=-tp t2o)))) (> (cmp-norm-tp `(real ,(cond ((numberp (car t2)) (list (car t2))) ((car t2)) ('*))))) (>= (cmp-norm-tp `(real ,(or (car t2) '*)))) (< (cmp-norm-tp `(real * ,(cond ((numberp (cadr t2)) (list (cadr t2))) ((cadr t2)) ('*))))) diff --git a/cmpnew/gcl_cmpmulti.lsp b/cmpnew/gcl_cmpmulti.lsp index 82cf9fff..b473ef43 100644 --- a/cmpnew/gcl_cmpmulti.lsp +++ b/cmpnew/gcl_cmpmulti.lsp @@ -272,9 +272,11 @@ (tp (if (eq tp '*) (make-list (length vars) :initial-element t) (cdr tp)))) (do ((v vars (cdr v)) (t1 tp (cdr t1))) ((not v)) - (set-var-init-type (car v) (if t1 (car t1) #tnull)))) - - (dolist (v vars) (push-var v init-form)) + (let* ((ntp (if t1 (car t1) #tnull)) + (ni (copy-info (cadr init-form)))) + (setf (info-type ni) ntp) + (set-var-init-type (car v) ntp) + (push-var (car v) (list* (car init-form) ni (cddr init-form)))))) (check-vdecl vnames ts is) diff --git a/cmpnew/gcl_cmpopt.lsp b/cmpnew/gcl_cmpopt.lsp index 533800c5..837f86ab 100644 --- a/cmpnew/gcl_cmpopt.lsp +++ b/cmpnew/gcl_cmpopt.lsp @@ -296,34 +296,43 @@ (push '((t t) t #.(flags ans) "number_divide(#0,#1)") (get 'si::number-divide 'inline-always)) (push '((cnum cnum) cnum #.(flags) "(#0)/(#1)") (get 'si::number-divide 'inline-always)) -;;/= - (push '((t t) boolean #.(flags rfa)"immnum_ne(#0,#1)") - (get '/= 'inline-always)) -(push '((cnum cnum) boolean #.(flags rfa)"(#0)!=(#1)") (get '/= 'inline-always)) +(deftype creals nil `(or float (and fixnum (signed-byte #.(1+ +sfbits+))))) +(deftype creall nil `(or long-float (and fixnum (signed-byte #.(1+ +lfbits+))))) +(deftype cnums nil `(or creals fcomplex dcomplex)) +(deftype cnuml nil `(or creall dcomplex)) + +(labels ((cop (op) (or (cdr (assoc op '((= . ==)(/= . !=)))) op)) + (minl (args s) `(,args boolean #.(flags rfa) ,s)) + (str (s) (string-downcase (remove #\- (string s)))) + (minla (op) (ms "((#0)" (cop op) "(#1))")) + (minlb (op args &aux (p (position 'fixnum args))(s (nth (- 1 p) args))) + (ms "(FIX" (if (member s '(short-float fcomplex)) "S" "L") "FSP(#" p ") ? " + "number_compare(make_" (if (zerop p) "fixnum" (str s)) "(#0),make_" + (if (zerop p) (str s) "fixnum") "(#1))" (cop op) "0 : " (minla op) ")")) + (minls (op args) (minl args (minlb op args))) + (minlf (op args) (minl args (minla op))) + (minlt (s iap) + (mapc (lambda (x) (when x (push x (get s 'inline-always)))) + (list + (minl '(t t) (ms "immnum_" iap "(#0,#1)")) + (unless (eq (cop s) s) (minls s '(fixnum fcomplex))) + (minls s '(fixnum short-float)) + (unless (eq (cop s) s) (minls s '(fcomplex fixnum))) + (minls s '(short-float fixnum)) + (unless (eq (cop s) s) (minls s '(fixnum dcomplex))) + (minls s '(fixnum long-float)) + (unless (eq (cop s) s) (minls s '(dcomplex fixnum))) + (minls s '(long-float fixnum)) + (minlf s '(fixnum fixnum)) + (minlf s (if (eq (cop s) s) '(creall creall) '(cnuml cnuml))) + (minlf s (if (eq (cop s) s) '(creals creals) '(cnums cnums))))))) + + (mapc (lambda (x) (apply #'minlt x)) '((< "lt")(<= "le")(> "gt")(>= "ge")(= "eq")(/= "ne")))) -;;< - (push '((t t) boolean #.(flags rfa)"immnum_lt(#0,#1)") (get '< 'inline-always)) -(push '((creal creal) boolean #.(flags rfa)"(#0)<(#1)") (get '< 'inline-always)) ;;compiler::objlt (push '((t t) boolean #.(flags rfa)"((object)(#0))<((object)(#1))") (get 'si::objlt 'inline-always)) -;;<= - (push '((t t) boolean #.(flags rfa)"immnum_le(#0,#1)") (get '<= 'inline-always)) -(push '((creal creal) boolean #.(flags rfa)"(#0)<=(#1)") (get '<= 'inline-always)) - -;;= - (push '((t t) boolean #.(flags rfa)"immnum_eq(#0,#1)") (get '= 'inline-always)) -(push '((cnum cnum) boolean #.(flags rfa)"(#0)==(#1)") (get '= 'inline-always)) - -;;> - (push '((t t) boolean #.(flags rfa)"immnum_gt(#0,#1)") (get '> 'inline-always)) -(push '((creal creal) boolean #.(flags rfa)"(#0)>(#1)") (get '> 'inline-always)) - -;;>= - (push '((t t) boolean #.(flags rfa)"immnum_ge(#0,#1)") (get '>= 'inline-always)) -(push '((creal creal) boolean #.(flags rfa)"(#0)>=(#1)") (get '>= 'inline-always)) - ;;APPEND ;; (push '((t t) t #.(flags ans)"append(#0,#1)") ;; (get 'append 'inline-always)) diff --git a/git.tag b/git.tag index eb7f1dc4..7df29434 100644 --- a/git.tag +++ b/git.tag @@ -1 +1 @@ -"Version_2_7_2pre37" +"Version_2_7_2pre38" diff --git a/h/compdefs.h b/h/compdefs.h index db7aeb62..26827a81 100644 --- a/h/compdefs.h +++ b/h/compdefs.h @@ -95,3 +95,5 @@ NO_RETURN CHAR_SIZE MAX_ARGS bool +FIXSFSP(x) +FIXLFSP(x) diff --git a/h/elf32_ppc_reloc.h b/h/elf32_ppc_reloc.h index 7882329a..06339434 100644 --- a/h/elf32_ppc_reloc.h +++ b/h/elf32_ppc_reloc.h @@ -2,7 +2,7 @@ s+=a; if (ovchks(s,~MASK(26))) store_val(where,MASK(26),s|0x3); - else if (ovchks(s-p,~MASK(26))) + else if (ovchks(s-p,~MASK(26))) store_val(where,MASK(26),(s-p)|0x1); else massert(!"REL24 overflow"); break; diff --git a/h/notcomp.h b/h/notcomp.h index 35646f40..589ecdc6 100755 --- a/h/notcomp.h +++ b/h/notcomp.h @@ -362,3 +362,15 @@ EXTER gmp_randfnptr_t Mersenne_Twister_Generator_Noseed; type_of(strm_)==t_stream ? read_object_non_recursive(strm_) : fSread_fasd_top(strm_) #define NO_TRUENAME (raw_image || no_truename) + + +#define UFIX(x) ({fixnum _x=(x);_x^(_x>>(sizeof(fixnum)*8-1));}) + +#define SFBITS 24 +#define LFBITS 53 + +#define FMSK(a_) ((~(0ULL))&(~((1ULL<<(a_))-1))) + +#define FIXSFSP(x) (UFIX(x)&FMSK(SFBITS)) +#define FIXLFSP(x) (UFIX(x)&FMSK(LFBITS)) + diff --git a/lsp/gcl_deftype.lsp b/lsp/gcl_deftype.lsp index 0e1ad466..e7621571 100644 --- a/lsp/gcl_deftype.lsp +++ b/lsp/gcl_deftype.lsp @@ -279,7 +279,7 @@ (ratio (let ((z (rational nx))) (if (eql z nx) (if (integerp x) (list x) x) - (if a z (list z))))) + (if (unless (integerp z) a) z (list z))))) (short-float (f 0.0s0)) (long-float (f 0.0))))) diff --git a/o/num_comp.c b/o/num_comp.c index c4c364d5..559ff36c 100644 --- a/o/num_comp.c +++ b/o/num_comp.c @@ -42,7 +42,6 @@ number_compare(object x, object y) { double dx; static double dy; - object q; enum type tx,ty; tx=type_of(x); @@ -70,6 +69,7 @@ number_compare(object x, object y) { return(number_compare(x, y)); case t_shortfloat: + if (FIXSFSP(fix(x))) return number_compare(x,double_to_rational(sf(y)));/*(fix(x)&0x7FFFFFFFFF000000)*/ { volatile float fx=fix(x); dx = fx; @@ -78,6 +78,7 @@ number_compare(object x, object y) { goto LONGFLOAT; case t_longfloat: + if (FIXLFSP(fix(x))) return number_compare(x,double_to_rational(lf(y))); dx = fix(x); dy = lf(y); goto LONGFLOAT; @@ -106,21 +107,10 @@ number_compare(object x, object y) { return(number_compare(x, y)); case t_shortfloat: - - if ((float)number_to_double((q=double_to_integer((double)sf(y))))==sf(y)) - return(number_compare(x,q)); - - dx=number_to_double(x); - dy=sf(y); - goto LONGFLOAT; + return number_compare(x,double_to_rational(sf(y))); case t_longfloat: - if (number_to_double((q=double_to_integer(lf(y))))==lf(y)) - return(number_compare(x,q)); - - dx=number_to_double(x); - dy=lf(y); - goto LONGFLOAT; + return number_compare(x,double_to_rational(lf(y))); case t_complex: goto Y_COMPLEX; @@ -176,6 +166,9 @@ number_compare(object x, object y) { case t_fixnum: + if (tx==t_shortfloat ? FIXSFSP(fix(y)) : FIXLFSP(fix(y))) + return number_compare(double_to_rational(dx),y); + if (tx==t_shortfloat) { volatile float fy=fix(y); dy=fy; @@ -184,11 +177,7 @@ number_compare(object x, object y) { goto LONGFLOAT; case t_bignum: - - if (number_to_double((q=double_to_integer(dx)))==dx) - return(number_compare(q,y)); - dy=number_to_double(y); - goto LONGFLOAT; + return number_compare(double_to_rational(dx),y); case t_ratio: return(number_compare(double_to_rational(dx),y)); @@ -332,6 +321,9 @@ DEFUN("/=2",object,fSne2,SI } +DEFCONST("+SFBITS+",sSPsfbitsP,SI,small_fixnum(SFBITS),"Mantissa bits in short-float"); +DEFCONST("+LFBITS+",sSPsfbitsP,SI,small_fixnum(LFBITS),"Mantissa bits in short-float"); + DEFUN("MAX2",object,fSx2,SI ,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { diff --git a/o/num_sfun.c b/o/num_sfun.c index 7fd39b24..f42c0582 100644 --- a/o/num_sfun.c +++ b/o/num_sfun.c @@ -675,8 +675,8 @@ LFD(Lexp)(void) DEFUN("EXPT",object,fLexpt,LISP,2,2,NONE,OO,OO,OO,OO,(object x,object y),"") { - check_type_number(&vs_base[0]); - check_type_number(&vs_base[1]); + check_type_number(&x); + check_type_number(&y); RETURN1(number_expt(x,y)); }